unit uSBDUnit_TestExecution;
interface
uses Classes, Generics.Collections, Windows, Messages, uSBDUnit_JobMill,
     uSBDUnit_Types, uSBD_BaseTypes;

const
  DefaultMessageNum = WM_USER + 21;
type

TNodeStatus = (
  nsNeutral,    // This node is in the queue to be processed.
  nsDoing,      // We are currently procesing this node or one of its children.
  nsDone,       // This node has been processed, either successfully or not.
  nsSkipped     // This node will not be processed.
  );
TNodeStatusSet = set of TNodeStatus;


ITestPoint = interface
['{92541484-4115-437E-B2AC-978617026259}']
    {$REGION 'property accessors'}
    function  GetStatus: TNodeStatus;
    procedure SetStatus( Value: TNodeStatus);
    function  GetExecResult: TExecutionResult;
    procedure SetExecResult( Value: TExecutionResult);
    {$ENDREGION}
    procedure PreExecute;
    function  Execute: boolean;
    procedure PostExecute( isTimedOut: boolean);
    function  TimeOut: integer;
    function  doInbackground: boolean;

    property Status: TNodeStatus   read GetStatus write SetStatus;
    property ExecutionResult: TExecutionResult  read GetExecResult write SetExecResult;
  end;

TTestEnumerable = TEnumerable<ITestPoint>;

ITestProgramClient = interface
  ['{D4D426D6-03FC-49D4-8C9F-5E565F7F5F12}']
  procedure NodeStatusChanged( Node: ITestPoint);
  procedure RunStatusChanged;
  function  DoContinue: boolean; // False if user abort.
  end;


// Implicit contructor inputs:
//  *  FWindowClient:  IMainThreadedWindowedClient;  -- Injected as a live service.
//  *  FClient: ITestProgramClient -- Injected as a live service. This is a vista to the Engine.
//  *  FMill: IJobMill;  -- Injected as a created service, But may be released and a new one created as required.
//  *  TestEnumerable1: TTestEnumerable; -- A getter service is injected.
//      The services is a created one. This service has in turn its root node
//      injected. The root node is a live service.
//  *  doBreakOnFirstFail: boolean;  // Set by the client as a parameter to the Run method. Not a property.

ITestEnumerableGetter = interface
  ['{88E79DD4-F9E0-4C9C-A5AA-46C527DB698D}']
    function CreateTestEnumerable: TTestEnumerable;
    // ^--- Uses an [Injection('EnumerationRoot')] to locate the root node.
  end;

ITestProgram = interface
  ['{36F259B2-91EF-4F30-B58F-40D139B5E4B8}']
    procedure Run( doBreakOnFirstFail: boolean);
    procedure Clear;
  end;

TTestProgram = class;
TNodeJob = class sealed( TJob)
  protected
    FProgram: TTestProgram;
    FCurrentNode: ITestPoint;

    procedure   Execute_InThread;        override;
    procedure   Execute_OutOfThread;     override;
  end;


TTestProgram = class( TSBD_RefCountedCommonBase)
  private
    [Injection] FTestEnumGetter: ITestEnumerableGetter;
    [Injection] FWindowClient:  IMainThreadedWindowedClient;
    [Injection] FClient: ITestProgramClient;
    [Injection] FMill: IJobMill;

    FTestEnumerable: TTestEnumerable;
    FCurrentJob: TNodeJob;
    FWindHandle: HWND;
    FMessageNum: cardinal;

    procedure OnPollOutputThread( Sender: TObject);
    procedure JobReturns( var Message1: TMessage{TJobReadyForPickup});
    procedure OnTimeOut( Sender: TObject);
    procedure ConcludeJob( Job: TNodeJob; isTimedOut: boolean);
    procedure ReEnter;

  protected
    procedure PostInjectionInit( const Config1: string; const Client: IInterface);     override;
    class function  ExceptionClass: TSBDUnit_ExceptionClass;                           override;

  public
    FCountDone: integer;
    FTotal: integer;
    FisDone: boolean;
    FFailCount: integer;
    FdoBreakOnFirstFail: boolean;

    procedure Run;
    procedure Clear;

    [Configuration] constructor ServiceModeCreate;
    constructor Create( TestEnumerable1: TTestEnumerable;
                        const WindowClient1:  IMainThreadedWindowedClient;
                        const Client1: ITestProgramClient;
                        doBreakOnFirstFail: boolean);
  end;
implementation





{ TTestProgram }

procedure TTestProgram.OnPollOutputThread( Sender: TObject);
begin
if assigned( FWindowClient) then
  FWindowClient.Breathe
end;



procedure TTestProgram.Run;
var
  Node: ITestPoint;
begin
FTotal := 0;
for Node in FTestEnumerable do
  Inc( FTotal);
FisDone := False;
FCountDone := 0;
FFailCount := 0;
for Node in FTestEnumerable do
  begin
  Node.ExecutionResult := erNull;
  Node.Status          := nsNeutral
  end;
FClient.RunStatusChanged;
ReEnter
end;


constructor TTestProgram.ServiceModeCreate;
begin

end;

{$WARNINGS OFF}
procedure TTestProgram.ReEnter;
var
  Node: ITestPoint;
  Ok: boolean;
  isTimedOut: boolean;
begin
for Node in FTestEnumerable do
  begin
  if not FClient.DoContinue then
    begin
    // User abort detected.
    FisDone := True;
    break
    end;
  if Node.Status <> nsNeutral then continue;
  Node.Status := nsDoing;
  Node.PreExecute;
  isTimedOut := False;
  if Node.doInBackground then
      begin
      if not assigned( FMill) then
        begin
//        if assigned( FWindowClient) then
//            FMill := FJobMillService.CreateJobMill( OnPollOutputThread)
//          else
//            FMill := FJobMillService.CreateJobMill( nil)
        end;
      FCurrentJob := TNodeJob.Create( []);
      FCurrentJob.FProgram := self;
      FCurrentJob.FCurrentNode := Node;
      if assigned( FWindowClient) then
        begin
        FWindHandle := FWindowClient.MainWindowHandle;
        FWindowClient.SetUnitTestHandler( JobReturns, FMessageNum, FCurrentJob);
        FWindowClient.SetTimer( OnTimeOut, Node.TimeOut, FCurrentJob);
        end;
      FMill.QueueJob( FCurrentJob);
      if assigned( FWindowClient) then
          break
        else
          begin
          isTimedOut := not FMill.WaitPop( Node.TimeOut);
          if isTimedOut then
              begin
              FMill.KillThread;
              FMill := nil;
              Ok := False
              end
            else
              Ok := Node.ExecutionResult = erPass
          end
      end
    else
      Ok := Node.Execute;
  if Ok then
      Node.ExecutionResult := erPass
    else
      Node.ExecutionResult := erFail;
  Node.PostExecute( isTimedOut);
  if Ok and (Node.ExecutionResult = erFail) then
    Ok := False; // This is the way PostExecute can signal fail.
  Node.Status := nsDone;
  Inc( FCountDone);
  FisDone := FCountDone >= FTotal;
  if not Ok then
    inc( FFailCount);
  FCurrentJob := nil;
  if (FFailCount >= 1) and FdoBreakOnFirstFail then break;
  if assigned( FWindowClient) then
    FWindowClient.Breathe
  end;
if FisDone then
  begin
  for Node in FTestEnumerable do
    if Node.Status <> nsDone then
      Node.Status := nsSkipped;
  FMill := nil;
  FClient.RunStatusChanged
  end;
end;
{$WARNINGS ON}


constructor TTestProgram.Create( TestEnumerable1: TTestEnumerable;
  const WindowClient1: IMainThreadedWindowedClient;
  const Client1: ITestProgramClient; doBreakOnFirstFail: boolean);
begin
FTestEnumerable := TestEnumerable1;
FWindowClient   := WindowClient1;
FClient         := Client1;
FdoBreakOnFirstFail := doBreakOnFirstFail;
FMill := nil;
FCurrentJob := nil;
FWindHandle := 0;
FMessageNum := DefaultMessageNum;
if assigned( FWindowClient) then
  FWindowClient.GetUnitTestMessageNum( FMessageNum);
FCountDone  := 0;
FTotal      := 0;
FisDone     := True;
FFailCount  := 0
end;

class function TTestProgram.ExceptionClass: TSBDUnit_ExceptionClass;
begin

end;

procedure TTestProgram.Clear;
begin
FCurrentJob := nil;
FCountDone  := 0;
FTotal      := 0;
FisDone     := False;
FFailCount  := 0
end;


procedure TTestProgram.JobReturns( var Message1: TMessage);
begin
if Message1.Msg <> FMessageNum then exit;
if not FMill.WaitPop( 1000) then
  OnTimeOut( self);
Message1.Result := 1
end;


{ TNodeJob }

procedure TNodeJob.Execute_InThread;
begin
if FCurrentNode.Execute then
    FCurrentNode.ExecutionResult := erPass
  else
    FCurrentNode.ExecutionResult := erFail
end;

procedure TTestProgram.ConcludeJob( Job: TNodeJob; isTimedOut: boolean);
begin
if assigned( FWindowClient) then
  begin
  FWindowClient.ClearUnitTestHandler( Job);
  FWindowClient.ClearTimer( Job)
  end;
if isTimedOut then
  begin
  FMill.KillThread;
  FMill := nil
  end;
if isTimedOut then
    Job.FCurrentNode.ExecutionResult := erFail
  else
    Job.FCurrentNode.ExecutionResult := Job.FCurrentNode.ExecutionResult;
Job.FCurrentNode.PostExecute( isTimedOut);
Job.FCurrentNode.Status := nsDone;
Inc( FCountDone);
FisDone := FCountDone >= FTotal;
if Job.FCurrentNode.ExecutionResult = erFail then
  inc( FFailCount);
FCurrentJob := nil;
ReEnter
end;

procedure TNodeJob.Execute_OutOfThread;
begin
FProgram.ConcludeJob( self, False)
end;

procedure TTestProgram.OnTimeOut( Sender: TObject);
begin
ConcludeJob( FCurrentJob, True)
end;



procedure TTestProgram.PostInjectionInit(const Config1: string;
  const Client: IInterface);
begin
  inherited;

end;

end.
